home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / metamail / contrib / emacs / gnus-mime.el < prev    next >
Encoding:
Text File  |  1993-05-24  |  14.5 KB  |  441 lines
  1. ;;;  gnus-mime.el
  2. ;;;  Support to read/post MIME format USENET articles in GNUS.
  3. ;;;  Version 0.2
  4.  
  5. ;;  Author Spike <Spike@world.std.com>
  6. ;;  with code from Michael Littman's <mlittman@breeze.bellcore.com>
  7. ;;  richtext.el and metamail's MH-E patches.
  8.  
  9.  
  10. ;;  This requires that you have the metamail package installed
  11. ;;  (thumper.bellcore.com:/pub/nsb/mm.tar.Z) and transparent.el
  12.   
  13. ;;  This package provides five basic functions
  14. ;;
  15. ;;  gnus-Subject-run-metamail - invokes metamail on the selected news article.
  16. ;;  gnus-inews-article - replaces the standard gnus-inews-article with one
  17. ;;                       which inserts MIME headers and does Richtext style
  18. ;;                       signatures.  It also supports multi-media signatures
  19. ;;                       if ".signature-MIME" or ".signature-distriubtion-MIME"
  20. ;;                       exists, it is inserted and any line which reads:
  21. ;;                       --MIME-BOUNDARY
  22. ;;                       is replaced with the current boundary.
  23. ;;  gnus-richtext-posting - converts the posting buffer to Richtext format,
  24. ;;                          knows how to make text bold, italics, and
  25. ;;                          underlined.
  26. ;;  gnus-insert-file-as-mime - Allows you to insert arbitrary data into
  27. ;;                             a posting in MIME format.  Automatically
  28. ;;                             recognizes some formats (GIF, JPEG, PS),
  29. ;;                             more can be add through "auto-mime-id-list".
  30. ;;  gnus-insert-file-as-mime-external - Allows you to create a reference to
  31. ;;                                      an external file.
  32.  
  33. ;;  As shiped this binds gnus-Subject-run-metamail to "@" in the "*Subject*"
  34. ;;  buffer.  gnus-richtext-posting to "C-c r", "gnus-insert-file-as-mime" to
  35. ;;  "C-c i", and "gnus-insert-file-as-mime -external" to "C-c e" in the posting
  36. ;;  buffer.
  37. ;;
  38.  
  39. ;;  To use put "(load-library "gnus-mime.el")" in your ".emacs" or "default.el"
  40.  
  41. ;;  If you want GNUS to announce MIME postings but something like:
  42. ;;  (setq gnus-Article-prepare-hook
  43. ;;       '(lambda ()
  44. ;;      (gnus-Subject-check-content-type)))
  45. ;;  in your ".emacs" file.
  46.  
  47. ;; CAVEATS: You can not call gnus-richtext-posting after calling
  48. ;; gnus-insert-file-as-mime or gnus-insert-file-as-mime-external
  49.  
  50. (require 'transparent)
  51. (load-library "rnewspost") ;; sigh...  This could be better.
  52. (require 'gnuspost)
  53. (provide 'gnus-mime)
  54.  
  55. (defvar gnus-invoke-mime-key "@" 
  56.   "The key that calls gnus-Subject-run-metamail")
  57.  
  58. (define-key gnus-Subject-mode-map gnus-invoke-mime-key
  59.   'gnus-Subject-run-metamail)
  60.  
  61. (define-key news-reply-mode-map "\C-cr" 'gnus-richtext-posting)
  62. (define-key news-reply-mode-map "\C-ci" 'gnus-insert-file-as-mime)
  63. (define-key news-reply-mode-map "\C-ce" 'gnus-insert-file-as-mime-external)
  64.  
  65. (defvar auto-mime-id-list nil "\
  66. A list of filename patterns vs corresponding MIME type strings
  67. Each element looks like (REGEXP . TYPE).")
  68. (setq auto-mime-id-list (mapcar 'purecopy
  69.                               '(("\\.gif$" . "image/gif")
  70.                 ("\\.jpg$" . "image/jpeg")
  71.                 ("\\.xwd$" . "image/x-xwd")
  72.                 ("\\.ps$"  . "application/PostScript"))))
  73.  
  74. ;;;;;;
  75.  
  76. (defun gnus-Subject-check-content-type ()
  77.   (if (gnus-fetch-field "Mime-Version")
  78.       (let ((content-type (gnus-fetch-field "Content-Type")))
  79.        (message (concat "You can use '" gnus-invoke-mime-key 
  80.                 "' to view this '" content-type 
  81.                 "' MIME format article.")))))
  82.  
  83. (defun gnus-Subject-run-metamail ()
  84.   (interactive)
  85.   "Process Selected Article Through \"metamail\"."
  86.   (gnus-Subject-select-article)
  87.   (gnus-eval-in-buffer-window gnus-Article-buffer
  88.   (let ((metamail-tmpfile (make-temp-name "/tmp/rmailct")))
  89.     (save-restriction
  90.       (widen)
  91.       (write-region (point-min) (point-max) metamail-tmpfile))
  92.     (if 
  93.     (and window-system (getenv "DISPLAY"))
  94.     (let ((buffer-read-only nil))
  95.       (push-mark (point) t)
  96.       (erase-buffer)
  97.       (call-process "metamail" nil t t
  98.          "-m" "mh-e" "-x" "-d" "-q" "-z" metamail-tmpfile)
  99.       (exchange-point-and-mark)
  100.       (set-buffer-modified-p nil)
  101.       (other-window -1))
  102.       (progn
  103.     (other-window -1)
  104.     (switch-to-buffer "METAMAIL")
  105.     (erase-buffer)
  106.     (sit-for 0)
  107.     (transparent-window
  108.      "METAMAIL"
  109.      "metamail"
  110.      (list "-p" "-d" "-q" metamail-tmpfile)
  111.      nil
  112.      (concat
  113.       "\n\r\n\r*****************************************"
  114.       "*******************************\n\rPress any key "
  115.       "to go back to EMACS\n\r\n\r***********************" 
  116.       "*************************************************\n\r")))
  117.       )
  118.     )
  119.   )
  120.  )
  121.  
  122.  
  123. (defvar rich-substitutions
  124.       '(
  125.         ("<"        "<lt>") ; in case some one sends less-thans.
  126.         ("\\B%\\b" "</italic>") ; needs to be first to not get closing tags.
  127.         ("\\b%\\B" "<italic>")
  128.         ("\\B\\*\\b" "<bold>")
  129.         ("\\b\\*\\B" "</bold>")
  130.         ("
  131. " "
  132. <nl>")
  133.         ("\\B_\\b" "<underline>")
  134.         ("\\b_\\B" "</underline>")
  135.         )
  136.       "A table of REGEXP to translate text to MIME's text/richtext format.")
  137.  
  138. (defun gnus-richtext-posting ()
  139.   "Convert the current buffer to MIME's \"text/richtext\" format.
  140. \"*foo*\" is converted to bold, \"%foo%\" to italics, and \"_foo_\" to
  141. underlined. Note: this does not recognize font markers *after*
  142. punctuation, thus \"*foo!*\" will not work."
  143.   (interactive)
  144.   (mail-position-on-field "Subject")
  145.   (or (gnus-fetch-field "Mime-Version")
  146.       (insert "\nMime-Version: 1.0"))
  147.   (or (gnus-fetch-field "Content-Type")
  148.       (insert "\nContent-Type: text/richtext"))
  149.   (goto-char (point-min))
  150.   (search-forward (concat "\n" mail-header-separator "\n") nil t)
  151.   (perform-rich-sub)
  152.   )
  153.  
  154. (defun perform-rich-sub ()
  155.   "Perform the rich substiution."
  156.   (let ((subs rich-substitutions)
  157.         pat rep
  158.         (top (point)))
  159.     (save-excursion
  160.       (while subs
  161.         (setq pat (car (car subs)))
  162.         (setq rep (car (cdr (car subs))))
  163.         (setq subs (cdr subs))
  164.         (goto-char top)
  165.         (while (re-search-forward pat (point-max) t)
  166.           (replace-match rep))
  167.         ))))
  168.  
  169. (defun gnus-insert-file-as-mime (filename)
  170.   "Encode and insert a file into the posting buffer and setup the correct
  171. MIME headers for that file type."
  172.   (interactive "FFind file: ")
  173.   (let ((ctype nil)
  174.     (binary nil)
  175.     (boundary nil))
  176.     (setq ctype (gnus-get-mime-content-type filename))
  177.     (setq boundary (gnus-fetch-or-create-boundary))
  178.     (goto-char (point-max))
  179.     (search-backward boundary (point-min) t)
  180.     (forward-line)
  181.     (insert-file filename)
  182.     (save-excursion
  183.       (if (re-search-forward "[\200-\377]" nil t)
  184.       (setq binary t)))
  185.     (if binary
  186.     (save-excursion
  187.       (shell-command-on-region (point) (mark) "mmencode" t)))
  188.     (insert (concat "Content-type: " ctype "\n"))
  189.     (insert "Content-Transfer-Encoding: ")
  190.     (if binary
  191.     (insert "base64\n\n")
  192.       (insert "7BIT\n\n"))
  193.     (goto-char (point-max))
  194.     (insert (concat "\n--" boundary "\n"))
  195.     ))
  196.  
  197. (defun gnus-inews-article ()
  198.   "NNTP inews interface."
  199.   (let ((signature
  200.      (if gnus-signature-file
  201.          (expand-file-name gnus-signature-file nil)))
  202.     (distribution nil)
  203.     (artbuf (current-buffer))
  204.     (tmpbuf (get-buffer-create " *GNUS-posting*"))
  205.     (ctype nil)
  206.     (boundary nil))
  207.     (save-excursion
  208.       (set-buffer tmpbuf)
  209.       (buffer-flush-undo (current-buffer))
  210.       (erase-buffer)
  211.       (insert-buffer-substring artbuf)
  212.       ;; Get distribution.
  213.       (setq distribution (gnus-fetch-field "Distribution"))
  214.       (if signature
  215.       (progn
  216.         ;; Change signature file by distribution.
  217.         ;; Suggested by hyoko@flab.fujitsu.junet.
  218.         (if (file-exists-p (concat signature "-" distribution))
  219.         (setq signature (concat signature "-" distribution)))
  220.         ;; Insert signature.
  221.         (if (file-exists-p (concat signature "-MIME"))
  222.         ;; Random MIME format signature
  223.         (progn
  224.           (setq boundary (gnus-fetch-or-create-boundary))
  225.           (goto-char (point-max))
  226.           (insert-file-contents (concat signature "-MIME"))
  227.           (while (re-search-forward "^--MIME-BOUNDARY$" (point-max) t)
  228.             (replace-match (concat "--" boundary) t))
  229.           (goto-char (point-max))
  230.           (insert (concat "\n--" boundary "\n")))
  231.           ;; else "normal" signature
  232.           (if (file-exists-p signature)
  233.           (progn
  234.             ;; Use richtext signature format if possable.
  235.             (if (setq boundary (gnus-fetch-boundary))
  236.             (progn
  237.               (goto-char (point-max))
  238.               (insert "Content-type: text/richtext\n")
  239.               (insert "Content-Transfer-Encoding: quoted-printable\n\n")
  240.               ))
  241.             (if (or boundary 
  242.                 (string-equal (gnus-fetch-field "Content-Type")
  243.                       "text/richtext"))
  244.             (progn
  245.               (goto-char (point-max))
  246.               (insert "<signature>")
  247.               (insert-file-contents signature)
  248.               (goto-char (point-max))
  249.               (insert "</signature>\n")
  250.               (insert (concat "--" boundary "\n")))
  251.               (progn
  252.             (goto-char (point-max))
  253.             (insert "--\n")
  254.             (insert-file-contents signature)))
  255.           )))))
  256.       ;; Prepare article headers.
  257.       (save-restriction
  258.     (goto-char (point-min))
  259.     (search-forward "\n\n")
  260.     (narrow-to-region (point-min) (point))
  261.     (gnus-inews-insert-headers)
  262.     ;; insert mime headers if needed.
  263.     (goto-char (point-max))
  264.     (forward-line -2)
  265.     (or (gnus-fetch-field "Mime-Version")
  266.         (insert "Mime-Version: 1.0\n"))
  267.     (or (gnus-fetch-field "Content-Type")
  268.         (insert "Content-Type: text\n"))
  269.     ;; Save author copy of posted article. The article must be
  270.     ;;  copied before being posted because `gnus-request-post'
  271.     ;;  modifies the buffer.
  272.     (let ((case-fold-search t))
  273.       ;; Find and handle any FCC fields.
  274.       (goto-char (point-min))
  275.       (if (re-search-forward "^FCC:" nil t)
  276.           (gnus-inews-do-fcc))))
  277.       (widen)
  278.       ;; Run final inews hooks.
  279.       (run-hooks 'gnus-Inews-article-hook)
  280.       ;; Post an article to NNTP server.
  281.       ;; Return NIL if post failed.
  282.       (prog1
  283.       (gnus-request-post)
  284.     (kill-buffer (current-buffer)))
  285.       )))
  286.  
  287. (defun gnus-insert-file-as-mime-external ()
  288.   "Setup an external Content-Type header"
  289.   (interactive)
  290.   (let  ((access-type)
  291.      (site nil)
  292.      (directory nil)
  293.      (filename nil)
  294.      (ftp-mode nil)
  295.      (ctype nil)
  296.      (server nil)
  297.      (encoding nil)
  298.      (access-types-list
  299.       '(("ftp") ("anon-ftp") ("tftp") ("afs") ("local-file")
  300.         ("mail-server"))))
  301.     (setq access-type (completing-read "access-type: " access-types-list
  302.                                             nil t nil))
  303.     (cond
  304.                    
  305.      ((or (string-equal access-type "ftp")
  306.       (string-equal access-type "anon-ftp"))
  307.       (setq site (read-string "The hostname of the FTP site: "))
  308.       (setq directory 
  309.         (read-string
  310.          "The directory containing the file (Hit Enter for top-level): "))
  311.       (setq filename (read-string "The name of the file: "))
  312.       (setq ftp-mode (completing-read "FTP transfer type: " 
  313.                       '(("image") ("ascii") ("ebcdic"))
  314.                     nil t nil))
  315.       )
  316.      ((or (string-equal access-type "local-file")
  317.       (string-equal access-type "afs"))
  318.       (setq filename
  319.         (expand-file-name
  320.          (read-file-name "The full pathname of the file: " nil nil t)))
  321.       )
  322.      ((string-equal access-type "mail-server")
  323.       (setq server (read-string "The Email address of the mail server: "))
  324.       )
  325.     )
  326.     (setq ctype (gnus-get-mime-content-type filename))
  327.     (setq encoding (completing-read "Encoding of remote file: " 
  328.                     '(("none") ("base64")
  329.                       ("uuencode") ("quoted-printable"))
  330.                     nil t nil))
  331.     (if (equal encoding "none") (setq encoding nil))
  332.     (setq boundary (gnus-fetch-or-create-boundary))
  333.     (goto-char (point-max))
  334.     (search-backward boundary (point-min) t)
  335.     (forward-line)
  336.     (insert "Content-type: message/external-body;\n")
  337.     (insert (concat "\taccess-type=\"" access-type "\""))
  338.     (if filename
  339.     (insert (concat ";\n\tname=\"" filename "\"")))
  340.     (if site
  341.     (insert (concat ";\n\tsite=\"" site "\"")))
  342.     (if directory
  343.     (insert (concat ";\n\tdirectory=\"" directory "\"")))
  344.     (if ftp-mode
  345.     (insert (concat ";\n\tmode=\"" ftp-mode "\"")))
  346.     (if server
  347.     (insert (concat ";\n\tserver=\"" server "\"")))
  348.     (insert (concat "\n\nContent-type: " ctype "\n"))
  349.     (if encoding
  350.         (insert (concat "Content-Transfer-Encoding: " encoding "\n"))
  351.       )
  352.     (insert "\n")
  353.     (goto-char (point-max))
  354.     (insert (concat "--" boundary "\n"))
  355.     (if (string-equal access-type "mail-server")
  356.     (progn
  357.       (forward-line -2)
  358.       (insert "\n\n")
  359.       (forward-line -1)
  360.       (message "Now enter the commands to pass to the mail server")))
  361.     )
  362.   )
  363.  
  364. (defun gnus-fetch-boundary ()
  365.   "Return the boundary or nil if we are not a mulitpart message"
  366.   (let ((boundary nil)
  367.     (ctype (gnus-fetch-field "Content-Type")))
  368.     (if (and ctype (string-match "multipart" ctype))
  369.     (progn
  370.       (string-match "boundary=\"" ctype)
  371.       (setq boundary (substring ctype (match-end 0)))
  372.       (string-match "\"" boundary)
  373.       (setq boundary 
  374.         (substring boundary 0 (- (match-end 0) 1)))))
  375.     boundary)
  376.   )
  377.  
  378. (defun gnus-fetch-or-create-boundary ()
  379.   "Return the boundary or create one."
  380.   (let 
  381.       ((boundary nil)
  382.        (encoding nil)
  383.        (ctype nil))
  384.     (if (not (setq boundary (gnus-fetch-boundary)))
  385.     (progn
  386.       (setq boundary
  387.         (concat 
  388.          "GNUS.BOUNDARY." (system-name) "." (current-time-string)))
  389.       (save-excursion
  390.         (mail-position-on-field "Subject")
  391.         (or (gnus-fetch-field "Mime-Version")
  392.         (insert "\nMime-Version: 1.0\n"))
  393.         ;; If there is alread a Content-Type header, wrap the existing
  394.         ;; data in boundaries, moving the old Content* headers inside
  395.         ;; the boundary.  We won't get here if it was already a "mixed"
  396.         ;; type.
  397.         (if (setq ctype (gnus-fetch-field "Content-Type"))
  398.         (progn
  399.           (setq encoding
  400.             (gnus-fetch-field "Content-Transfer-Encoding"))
  401.           (mail-position-on-field "Content-Type")
  402.           (beginning-of-line)
  403.           (delete-region (point) (progn (forward-line 1) (point)))
  404.           (mail-position-on-field "Content-Transfer-Encoding")
  405.           (beginning-of-line)
  406.           (delete-region (point) (progn (forward-line 1) (point))))
  407.           (progn
  408.         (setq ctype "text")
  409.         (setq encoding "7BIT")))
  410.         (goto-char (point-min))
  411.         (re-search-forward
  412.          (concat "^" (regexp-quote mail-header-separator) "\n"))
  413.         (insert (concat "--" boundary "\n"))
  414.         (insert (concat "Content-type: " ctype "\n"))
  415.         (insert (concat "Content-Transfer-Encoding: " encoding "\n"))
  416.         (goto-char (point-max))
  417.         (insert (concat "\n--" boundary "\n"))
  418.         (mail-position-on-field "Mime-Version")
  419.         (forward-line)
  420.         (insert (concat "Content-Type: multipart/mixed;\n"
  421.                  "\tboundary=\"" boundary "\"")))))
  422.   boundary)
  423.   )
  424.  
  425. (defun gnus-get-mime-content-type (filename)
  426.   "Return the Content-Type of a FILENAME, asking the user if need be."
  427.   (let ((mlist auto-mime-id-list)
  428.     (ctype nil)
  429.     (name filename))
  430.     (if filename
  431.       (while (and (not ctype) mlist)
  432.         (if (string-match (car (car mlist)) name)
  433.             (setq ctype (cdr (car mlist))))
  434.         (setq mlist (cdr mlist)))
  435.       )
  436.     (if (not ctype)
  437.     (setq ctype 
  438.           (read-string "MIME content type: " "application/octet-stream")))
  439.     ctype)
  440.   )
  441.